CD/PC Actual 9/CDACTUAL9.iso/share/Dos/VARIOS/pascal/SWAG9605.DDD/0091_FAST Sort text file(s).pas

Pascal/Delphi Source File | 1996-05-31 | 34.4 KB | 999 lines

(*
Program TSort;
   sort text file(s) in the current directory
   sort inputfile(s) outputfile
     case insensitive sort, (optional) skipping empty and duplicate lines

     inputfile(s) up to 248.
       DOS wildcards supported for input files
       input files are not altered
       abort if file error input file (file does not exist, read error)

     outputfile:
       if outputfile already does exist, it won't be sorted in memory,
       but instead only file merged with the temporary files
       ( so it has to be sorted already! ).

     setting DOS errorlevel to 0 on success, 1 if an error occurred.

   the more files to merge together, the slower the filemerge.
   all textlines will be written to temporary files, so there must be
   free disk space of at least the total size of the files to sort.

   if necessary, increase files= in config.sys and reboot,
   or run Quarterdeck's files.com or a similar program
   to increase the number of filehandles allowed by DOS
   (max 99 for DOS 2.x; max 254 for DOS 3.x or later).

   Author: Eddy Thilleman, first version: september 1994
   written in Borland Pascal version 7.01
   Donated to the public domain. No rights reserved.

   You can reach me in the international Pascal conferences of Ilink, RIME
   and Fidonet.

   modifications:
     may 1995: Uppercase and compare integrated in one asm routine (CompUCStr)
    june 1995: Upper routine removed (not used anymore)
               a few (not used) string variables removed
     aug 1995: more $DEFINE- and matching $IFDEF-directives added, so you
               can easily adjust the program
    sept 1995: Tsort can now eliminate duplicate lines if the file to be
               sorted fits entirely in memory
     feb 1996: added total input lines and total lines sorted in memory
     may 1996: added the Release TimeSlice $DEFINE-directive
 *)

{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}
{$M 16384,1024,655360}

 {$DEFINE ReleaseTimeSlice}
{ Release timeslices under a multitask environment, uses the DPMI call
  works under OS/2 and Windows, disable it if you don't want that }

 {$DEFINE NoDupes}
{  comment the above directive if you don't want to check for duplicate lines  }

(* {$DEFINE NoPlus} *)
{  uncomment the above directive if you want to delete lines terminated by
   '+' characters }

 {$DEFINE CheckLines}
{  comment the above directive if you don't want to skip empty lines or
   lines containing no chars >= ASCII 20h (=space)  }

 {$DEFINE Test_Lines}
{  comment the above directive if you don't want to test lines for zero length or
   containing no chars >= ASCII 20h or terminating '+' chars
   NOTE: if NoPlus or CheckLines is defined, Test_Lines will automatically
         be defined as well
         (because NoPlus and CheckLines are nested inside Test_Lines) }

{$IFDEF NoPlus}             (* if NoPlus is defined *)
  {$DEFINE Test_Lines}        (* Test_Lines must also be defined *)
{$ENDIF}                               (*    *)

{$IFDEF CheckLines}         (* if CheckLines is defined *)
  {$DEFINE Test_Lines}        (* Test_Lines must also be defined *)
{$ENDIF}                               (*    *)
        (* because NoPlus and CheckLines are nested inside Test_Lines *)

        (* nested directives compile fine, so you can now easily make
           variations because of the directives and some of them can also
           be combined, so I haven't tested all the variations or
           combinations of them. Let me know if you encounter any problem,
           so I can fix it. *)

Program TSort;

Uses
  Dos;

const
  NumbFiles=   254;
  nr2div   = 10000;        { number to divide for counter on filemerge }
type
  fht      = array[1..NumbFiles] of byte;
var
  NewFHT   : fht;
  OldFHT   : longint;
  OldSize  : word;

Const
  NoFAttr : word =   $1C;  { dir-, volume-, system attributen }
  FAttr   : word =   $23;  { readonly-, hidden-, archive attributes }
  MaxNrLines = 10000;  { max # lines to sort in memory in one run }
  MaxNrFiles =   248;  { max 249 open files (248 temp. files + 1 dest.file) }
  BufSize    =  8192;  { 8 KB for input- and output buffers }
  SmallBufS  =  1024;  { 1 KB for input temp.files }

Type
  String3   = String[ 3];
  String12  = String[12];
  LineStr   = String;
  ptrLine   = ^LineStr;
  BufType   = array [1..BufSize] of char;
  SmallBufT = array [1..SmallBufS] of char;
  tTxtFile  = record
                TxtFile  : text;
                Line     : string;
                EndOfFile: boolean;
                Error    : boolean;
                SmallBuf : SmallBufT;
              end;
  pTxtFile  = ^tTxtFile;

Const
  WhiteSpace : string3 = #00#09#255;

Var
  MarkPtr   : pointer;        { marks start of Heapmemory }
  aPtrLines : array [1..MaxNrLines] of ptrLine;
  aPtrFiles : array [1..MaxNrFiles] of pTxtFile;
  Line0     : String;         { temporary line }
  NrLine    : word;           { current # of line in memory }
  NrLines   : word;           { number of lines in memory   }
  InputFile : text;           { input file   }
  OutputFile: text;           { output file  }
  DestFile  : String;         { filename of destination file }
  SourceBuf : BufType;        { source text buffer      }
  DestBuf   : BufType;        { destination text buffer }
  FR        : SearchRec;      { FileRecord              }
  FMask     : String12;       { FileMask                }
  TempDir   : String3;        { temporary directory     }
  TempFile  : String;         { temporary output file   }
  TempNr    : byte;           { for name temp. file     }
  tNr,tMaxNr: byte;           { for name temp. file     }
  Temp      : String3;        { name for temp. file     }
  Exists    : boolean;
  ParamNr   : byte;
  OldExitProc : Pointer;
  t         : ptrLine;
  Ready     : boolean;
  divisor   : word;           { divisor for showing # of lines merged
                                inversely proportional to # of files  }
  fName     : string12;       { for padding filename }
  display   : string[79];
  number    : string[ 5];
  TotalIn   : longint;        { total of inputlines }
  TotalSort : longint;        { total of in-memory-sorted lines }
  tel       : word;           { count var }


procedure SetCursorOff; assembler;
asm
  mov  AH,$01
  mov  CX,$2B0C
  int  $10
end;

procedure SetCursorOn; assembler;
asm
  mov  AH,$01
  mov  CX,$0B0C
  int  $10
end;


function HeapFunc( Size: word ): byte; far; assembler;
  { return value of
      0 : failure, run-time error, immediate abortion
      1 : failure, New or GetMem returns a nil pointer
      2 : success, retry
    Borland Pascal Language Guide, page 265
    "HeapError variable"
  }
asm
  mov  ax, 1
end  { HeapFunc };


procedure MakeNewFHT;
  { create a new expanded file handle table }
begin
  Oldsize := MemW[PrefixSeg:$32];            { Store the old FHT size     }
  OldFHT  := MemL[PrefixSeg:$34];            { Store the old FHT address  }
  FillChar(NewFHT,NumbFiles,$ff);            { Fill new table with 255    }
  MemW[PrefixSeg:$32] := NumbFiles;          { Put new size in the psp    }
  MemL[PrefixSeg:$34] := longint(@NewFHT);   { new FHT address in psp     }
  move(Mem[PrefixSeg:$19],NewFHT,$15);       { put contents of old to new }
end; { MakeNewFHT }


function OpenTextFile( var InF: text; name: string; var buffer; size: word ): boolean;
begin
  Assign( InF, Name );
  SetTextBuf( InF, buffer, size );
  Reset( InF );
  OpenTextFile := (IOResult = 0);
end  { OpenTextFile };


function CreateTextFile( var OutF: text; name: string; var buffer: BufType ): boolean;
begin
  Assign( OutF, Name );
  SetTextBuf( OutF, buffer );
  Rewrite( OutF );
  CreateTextFile := (IOResult = 0);
end  { CreateTextFile };


function Exist( Name : string ) : Boolean;
  { Return true if directory or file with the same name is found}
var
  F    : file;
  Attr : Word;
begin
  Assign( F, Name );
  GetFAttr( F, Attr );
  Exist := (DosError = 0)
end;


function fExist( fName: string ) : boolean;
begin
  fExist := ( FSearch(fName,'') <> '' );
end;


procedure UniekeEntry( var Naam : string3 );
const
  min   = 128;
var
  Nbyte : array [0..3] of byte absolute Naam;
  Exists : boolean;

begin
  Nbyte [0] :=  3;  { filename of 3 characters }

  Exists := True;
  Nbyte [1] := 255;
  while (Nbyte [1] >= min) and Exists do
  begin
    Nbyte [2] := 255;
    while (Nbyte [2] >= min) and Exists do
    begin
      Nbyte [3] := 255;
      while (Nbyte [3] >= min) and Exists do
      begin
        Exists := Exist( Naam );
        if Exists then dec (Nbyte [3]);
      end;
      if Exists then dec (Nbyte [2]);
    end;
    if Exists then dec (Nbyte [1]);
  end;
end;  { UniekeEntry }


function fRename( var Source, Dest: string ): boolean; assembler;
  { rename file or move file on same drive  }
  { *no* error checking!                    }
  { source and dest will be zero terminated }
  { by adding the ASCII zero char to both   }
  { so there must be room left for one char }
  { but that is not checked                 }
  { (byte length is not affected)           }
asm     push  ds          { save ds                       }
        xor   ax, ax      { clear ax                      }

        lds   si, source  { DS:SI = @source               }
        mov   al, [si]    { load length byte              }
        inc   si          { point to first char           }
        mov   dx, si      { DS:DX = @source (for dos)     }
        add   si, ax      { get beyond end of string      }
        mov   [si], ah    { zero terminated string        }

        les   di, dest    { ES:DI = @dest                 }
        mov   al, [di]    { load length byte              }
        inc   di          { point to first char           }
        mov   si, di      { ES:DI = @dest (for dos)       }
        add   si, ax      { get beyond end of string      }
        mov   [si], ah    { zero terminated string        }

        mov   ah, 56h     { dos function rename file      }
        mov   cl, 23h     { file attribute mask           }
        int   21h         { call dos to rename file       }

        mov   ax, 0       { assume false return value     }
        jc    @exit       { error, return false           }
        inc   ax          { return value true             }
@exit:  pop   ds          { restore ds                    }
end;  { fRename }


procedure StrCopy( var Str1, Str2: string ); assembler;
  { copy str1 to str2 }
asm     mov   dx, ds      { save DS                       }
        lds   si, str1    { load in DS:SI pointer to str1 }
        cld               { string operations forward     }
        les   di, str2    { load in ES:DI pointer to str2 }
        xor   ch, ch      { clear CH                      }
        mov   cl, [si]    { length str1 --> CX            }
        inc   cx          { include length byte           }
    rep movsb             { copy str1 to str2             }
@exit:  mov   ds, dx      { finished, restore DS          }
end  { StrCopy };


procedure Byte2zStr( num, width: byte; var str: string ); assembler;
  { Byte to string with leading zeros }
asm
        std                 { string operations backwards }
        mov   al, [num]     { numeric value to convert    }
        mov   cl, [width]   { width of str                }
        xor   ch, ch        { clear ch                    }
        jcxz  @exit         { done?                       }
        les   di, str       { adress of str               }
        mov   [di], cl      { length of str               }
        add   di, cx        { start with last char str    }
@start: aam                 { divide al by 10             }
        add   al, 30h       { convert remainder to char   }
        stosb               { store digit                 }
        mov   al, ah        { move quotient to AL         }
        dec   cl            { count down                  }
        jcxz  @exit         { done?                       }
        jmp   @start        { next digit                  }
@exit:
end  { Byte2zStr };


function CompUCStr( var Str1, Str2: String ): ShortInt; Assembler;
  { Compare Str1 and Str2 case insensitive }
asm     mov   dx, ds                 { save ds                        }
        lds   si, str1               { ds:si = @str1                  }
        les   di, str2               { es:di = @str2                  }
        cld                          { string operations forwards     }
        lodsb                        { get length string1 in AL       }
        mov   ah, es:[di]            { get length string2 in AH       }
        inc   di
        mov   bx, ax                 { save both lengths in BX        }
        xor   cx, cx                 { clear cx                       }
        mov   cl, al                 { get length String1 in CX       }
        cmp   cl, ah                 { equal to length String2?       }
        jb    @len                   { CX stores minimum length       }
        mov   cl, ah                 { of string1 and string2         }
  @len: jcxz  @exit                  { quit if null                   }

 @loop: lodsb                        { str1[i] in AL                  }
        mov   ah, es:[di]            { str2[i] in AH                  }

        cmp   al, 'a'                { uppercase if 'a'..'z'          }
        jb    @1
        cmp   al, 'z'
        ja    @1
        sub   al, 20h

    @1: cmp   ah, 'a'                { uppercase if 'a'..'z'          }
        jb    @2
        cmp   ah, 'z'
        ja    @2
        sub   ah, 20h

    @2: cmp   al, ah                 { compare str1 to str2           }
        jne   @not                   { loop if equal                  }
        inc   di                     { next char str2                 }
        dec   cx                     { countdown                      }
        jcxz  @exit                  { strings same, Length also?     }
        jmp   @loop                  { go do next char                }

  @not: mov   bx, ax                 { BL = AL = String1[i],
                                       BH = AH = String2[i]           }
 @exit: xor   ax, ax
        cmp   bl, bh                 { length or contents comp        }
        je    @equal                 { str1 = str2: return  0         }
        jb    @lower                 { str1 < str2: return -1         }
        inc   ax                     { str1 > str2: return  1         }
        inc   ax
@lower: dec   ax
@equal: mov   ds, dx                 { restore ds                     }
end   { CompUCStr };


{$IFDEF Test_Lines}
procedure White2Space( var Str: string; const WhiteSpace: string ); assembler;
  { replace white space chars in Str by spaces
    the string WhiteSpace contains the chars to replace }
asm     push  ds                 { save DS                       }
        cld                      { string operations forwards    }
        les   di, str            { ES:DI points to Str           }
        xor   cx, cx             { clear cx                      }
        mov   cl, [di]           { length Str in cl              }
        jcxz  @exit              { if length of Str = 0, exit    }
        inc   di                 { point to 1st char of Str      }
        mov   dx, cx             { store length of Str           }
        mov   bx, di             { pointer to Str                }
        lds   si, WhiteSpace     { DS:SI points to WhiteSpace    }
        mov   ah, [si]           { load length of WhiteSpace     }

@start: cmp   ah, 0              { more chars WhiteSpace left?   }
        jz    @exit              { no, exit                      }
        inc   si                 { point to next char WhiteSpace }
        mov   al, [si]           { next char to hunt             }
        dec   ah                 { ah counting down              }
        xor   dh, dh             { clear dh                      }
        mov   cx, dx             { restore length of Str         }
        mov   di, bx             { restore pointer to Str        }
        mov   dh, ' '            { space char                    }
@scan:
  repne scasb                    { the hunt is on                }
        jnz   @next              { white space found?            }
        mov   [di-1], dh         { yes, replace that one         }
@next:  jcxz  @start             { if no more chars in Str       }
        jmp   @scan              { if more chars in Str          }
@exit:  pop   ds                 { we are finished.              }
end  { White2Space };
{$ENDIF}


{$IFDEF Test_Lines}
procedure RTrim( var Str: string ); assembler;
  { remove trailing spaces from str }
asm     { setup }
        std                      { string operations backwards   }
        les   di, str            { ES:DI points to Str           }
        xor   cx, cx             { clear cx                      }
        mov   cl, [di]           { length Str in cl              }
        jcxz  @exit              { if length of Str = 0, exit    }
        mov   bx, di             { bx points to Str              }
        add   di, cx             { start with last char in Str   }
        mov   al, ' '            { hunt for spaces               }

        { remove trailing spaces }
   repe scasb                    { the hunt is on                }
        jz    @null              { only spaces?                  }
        inc   cx                 { no, don't lose last char      }
@null:  mov   [bx], cl           { overwrite length byte of Str  }
@exit:
end  { RTrim };
{$ENDIF}

(*
procedure LTrim( var Str: string ); assembler;
  { remove leading white space from str }
asm     push  ds                 { save DS                            }
        cld                      { string operations forward          }
        lds   si, str            { DS:SI points to Str                }
        xor   cx, cx             { clear cx                           }
        mov   cl, [si]           { length Str --> cl                  }
        jcxz  @exit              { if length Str = 0, exit            }
        mov   bx, si             { save pointer to length byte of Str }
        inc   si                 { 1st char of Str                    }
        mov   di, si             { pointer to 1st char of Str --> di  }
        mov   al, ' '            { hunt for spaces                    }
        xor   dx, dx             { clear dx                           }

        { look for leading spaces }
   repe scasb                    { the hunt is on                     }
        jz    @done              { if only spaces, we are done        }
        inc   cx                 { no, don't lose 1st non-blank char  }
        dec   di                 { no, don't lose 1st non-blank char  }
        mov   dx, cx             { new lenght of Str                  }
        xchg  di, si             { swap si and di                     }
    rep movsb                    { move remaining part of Str         }
@done:  mov   [bx], dl           { new length of Str                  }
@exit:  pop   ds                 { finished, restore DS               }
end  { LTrim };
*)

procedure Pad( var Str: String; len: byte ); assembler;
  { pad str with spaces while length str < len }
  { len must not be greater than size( str )   }
  { this is not checked!                       }
asm
             les   di, str            { ES:DI = @str               }
             cld                      { string operations forward  }
             xor   ax, ax             { clear ax                   }
             mov   al, [di]           { load length byte in al     }
             and   al, al             { length str = 0?            }
             jz    @exit              { yes, done                  }

             xor   cx, cx             { clear cx                   }
             mov   cl, len            { load new length            }
             mov   bl, cl             { store new length           }
             sub   cl, al             { len - length str           }
             jna   @exit              { length str >= len          }

             mov   [di], bl           { set new length             }
             add   di, ax             { get to end of str          }
             inc   di                 { get beyond end of str      }
             mov   ax, '  '           { fill with spaces           }
             shr   cx, 1              { (len-length) / 2           }
             jnc   @pad               { if (len-lenght) even, pad  }
             mov   [di], al           { if odd # of spaces to fill }
             jcxz  @exit              { if only one space, exit    }
             inc   di                 { next destination           }
   @pad: rep stosw                    { pad with spaces            }
  @exit:
end; { Pad }


{$IFDEF CheckLines}
function LineOK( var str: string ) : Boolean; assembler;
  { Line contains chars > ASCII 20h ? }
asm     mov   dx, ds         { save DS                          }
        xor   ax, ax         { assume false return value        }
        xor   cx, cx         { clear cx                         }
        lds   si, str        { load in DS:SI pointer to Str     }
        mov   cl, [si]       { length Str --> cx                }
        jcxz  @exit          { if no characters, exit           }
        inc   si             { point to 1st character           }

        { look for chars > ASCII 20h }
@start: mov   bl, [si]       { load character                   }
        cmp   bl, ' '        { char > ASCII 20h?                }
        ja    @yes           { yes, return true                 }
        inc   si             { next character                   }
        dec   cx             { count down                       }
        jcxz  @exit          { if no more characters left, exit }
        jmp   @start         { try again                        }
@yes:   mov   ax, 1          { return value true                }
@exit:  mov   ds, dx         { restore DS                       }
end  { LineOK };
{$ENDIF}


procedure Sorting( min, max: word );
var
  n : byte;
  x : longint;

  {$S+}
  function IsLess( i1, i2: word ): boolean;
  begin
    IsLess := (CompUCStr( aPtrLines[i1]^, aPtrLines[i2]^ ) < 0);
  end;

  procedure QuickSort( left, right: word );
    { Case insensitive QuickSort }
  var
    lower, upper, middle: word;
  begin
    lower  := left;
    upper  := right;
    middle := (left+right) div 2;
    repeat
      while IsLess( lower , middle ) do inc( lower );
      while IsLess( middle, upper  ) do dec( upper );
      if lower <= upper then
      begin
        { swap pointers }
        t := aPtrLines[lower];
        aPtrLines[lower] := aPtrLines[upper];
        aPtrLines[upper] := t;
        inc( lower );
        dec( upper );
      end;
    until lower > upper;
    if left  < upper then QuickSort( left , upper );
    if lower < right then QuickSort( lower, right );
  end  { QuickSort };
  {$S-}

  function Sorted: boolean;
  Var
    i: word;
  begin
    Sorted := True;
    x := 0;
    For i := 1 to Pred( Max ) do
      if IsLess( Succ( i ), i ) then
      begin
        Sorted := False;
        inc( x );
      end;
    { end for i loop }
  end;

begin  { Sorting }
  n := 0;
  Str( NrLines:5, number );
  display := fName + ':' + Temp + '  ' + number + ' lines   Sorting ';
  while not Sorted do
  begin
    write( #13, display, n:5,' ',x:5 );
    inc( n );
    QuickSort( min, max );
  end;
  write( #13, display, n:5,' ',x:5 );
end;  { Sorting }


{$IFDEF Test_Lines}
procedure TestLines;
var
  i   : word;
  len : byte;

  procedure TrimLine;
  begin
    White2Space( aPtrLines[i]^, WhiteSpace );  { white space to spaces   }
    RTrim( aPtrLines[i]^ );                    { remove trailing spaces  }
    len := length( aPtrLines[i]^ );
  end;

{$IFDEF NoPlus}
  procedure TrimPlus;
  begin
    TrimLine;
    while aPtrLines[i]^[len] = '+' do
    begin
      dec( len );
      aPtrLines[i]^[0] := chr( len );
      TrimLine;
    end;
  end;
{$ENDIF}

begin
  for i := 1 to NrLines do
  begin
    len := length( aPtrLines[i]^ );
{$IFDEF NoPlus}
    TrimPlus;
{$ELSE}
    TrimLine;
{$ENDIF}
{$IFDEF CheckLines}
    if ((len = 0) or not LineOK( aPtrLines[i]^ )) then
      aPtrLines[i] := nil;             { invalid Line }
{$ENDIF}
  end;
end;  { TestLine }
{$ENDIF}


procedure Process( var SourceFile : string12 );

{$IFDEF NoDupes}
  function IsEqual( i1, i2: word ): boolean;
  begin
    IsEqual := (CompUCStr( aPtrLines[i1]^, aPtrLines[i2]^ ) = 0);
  end;
{$ENDIF}

begin
  if OpenTextFile( InputFile, SourceFile, SourceBuf, BufSize ) then
  begin
    while not EOF( InputFile ) and (IOResult = 0) do
    begin
      inc( TempNr );
      Byte2zStr( TempNr, 3, Temp );
      TempFile := TempDir + '\' + Temp;
      write( fName, ':', Temp, '  ' );
      if CreateTextFile( OutputFile, TempFile, DestBuf ) then
      begin
        { read lines from input files }
        Mark( MarkPtr );
        NrLine := 1;
        if (Length( Line0 ) = 0) then ReadLn( InputFile, Line0 );
        GetMem( aPtrLines[NrLine], Length( Line0 ) + 1 );

        while not EOF(InputFile) and (IOResult = 0)
            and (NrLine <= MaxNrLines) and (aPtrLines[NrLine] <> nil) do
        begin
          StrCopy( Line0, aPtrLines[NrLine]^ );
          ReadLn( InputFile, Line0 );
          Inc( NrLine );
          if (NrLine <= MaxNrLines) then
            GetMem( aPtrLines[NrLine], Length( Line0 )+1 );
        end; { while not memory full }

        if ((NrLine <= MaxNrLines) and (aPtrLines[NrLine] <> nil)) then
        begin
          if EOF(InputFile) then
          begin
            aPtrLines[NrLine]^ := Line0;
            Line0 := '';
          end;
        end
        else
          Dec( NrLine );
        NrLines := NrLine;
        TotalIn := TotalIn + NrLine;
        Write( NrLines:5, ' lines' );

{$IFDEF Test_Lines}
        { Test / Trim Lines }
        TestLines;
{$ENDIF}

        { sort pointers }
        Sorting( 1, NrLines );

{$IFDEF NoDupes}
        tel := 1;
        NrLine := 1;
        while NrLine < NrLines do
        begin
          if IsEqual( NrLine, NrLine+1 ) then
          begin
            while IsEqual( NrLine, NrLine+tel ) do
            begin
              aPtrLines[NrLine+tel] := nil;             { eliminate dupe }
              inc( tel );
            end;
          end;
          inc( NrLine, tel );
          tel := 1;
        end;
{$ENDIF}

        { write sorted lines in temp files }
        tel := 0;
        for NrLine := 1 to NrLines do
        begin
          if (aPtrLines[NrLine] <> nil) then
          begin
            Writeln( OutputFile, aPtrLines[NrLine]^ );
            inc( tel );
          end;
          if (IOResult <> 0) then
          begin
            writeln( 'Error writing ', TempFile );
            halt( 1 );
          end;
          aPtrLines[NrLine]^ := '';
          aPtrLines[NrLine] := nil;
        end;
        writeln( '   ', tel:5, ' lines' );
        TotalSort := TotalSort + Tel;
        Release( MarkPtr );
        Close( OutputFile );
      end  { if CreateTextFile }
      else
      begin
        writeln(' error creating file ', TempFile );
        Halt( 1 );
      end;  {if CreateTextFile }
    end;  {while not eof}
    Close( InputFile );
  end   { if OpenTextFile }
  else
    writeln(' error opening file ', SourceFile );
  { endif OpenTextFile }
{$IFDEF ReleaseTimeSlice}
  asm                { release time slice }
    mov   AX,$1680
    int   $2F
  end;
{$ENDIF}
end  { Sorting };


procedure MergeSort;
var nr: byte;
    count: longint;

{$IFDEF NoDupes}
  function IsEqual( i1, i2: word ): boolean;
  begin
    IsEqual := (CompUCStr( aPtrFiles[i1]^.Line, aPtrFiles[i2]^.Line ) = 0);
  end;
{$ENDIF}

  function IsLess( i1, i2: word ): boolean;
  begin
    IsLess := (CompUCStr( aPtrFiles[i1]^.Line, aPtrFiles[i2]^.Line ) < 0);
  end;

begin
  tNr := 1;
  tMaxNr := TempNr;
  if TempNr > MaxNrFiles then tMaxNr := MaxNrFiles;
  Mark( MarkPtr );

  New( aPtrFiles[tNr] );
  while (tNr < tMaxNr) and (aPtrFiles[tNr] <> nil) do
  begin
    Inc( tNr );
    New( aPtrFiles[tNr] );
  end;
  if (aPtrFiles[tNr] = nil) then dec( tNr );

  tMaxNr := tNr;
  for tNr := 1 to tMaxNr do    { open temp files and read first line }
  begin
    Byte2zStr( tNr, 3, Temp );
    TempFile := TempDir + '\' + Temp;
    if not OpenTextFile( aPtrFiles[tNr]^.TxtFile, TempFile, aPtrFiles[tNr]^.SmallBuf, SmallBufS ) then
    begin
      writeln( 'Error opening ', TempFile );
      halt( 1 );
    end;
    ReadLn( aPtrFiles[tNr]^.TxtFile, aPtrFiles[tNr]^.Line );
    if (IOResult <> 0) then
    begin
      writeln( 'Error reading ', TempFile );
      halt( 1 );
    end;
    aPtrFiles[tNr]^.EndOfFile := EOF( aPtrFiles[tNr]^.TxtFile );
    aPtrFiles[tNr]^.Error := (IOResult <> 0);
  end;
  divisor := (nr2div div tMaxNr);

  if CreateTextFile( OutputFile, DestFile, DestBuf ) then
  begin
    count := 0;
    nr := 1;
    Ready := False;
    while not Ready do
    begin
      for tNr := 1 to tMaxNr do      { take alphabetically the first line }
      begin
        if tNr <> nr then
        begin
          if Length( aPtrFiles[tNr]^.Line ) > 0 then
          begin
{$IFDEF NoDupes}
            while IsEqual( tNr, nr )
            and not aPtrFiles[tNr]^.EndOfFile
            and not aPtrFiles[tNr]^.Error
            do     { no duplicates }
            begin
              ReadLn( aPtrFiles[tNr]^.TxtFile, aPtrFiles[tNr]^.Line );
              aPtrFiles[tNr]^.Error := (IOResult <> 0);
              aPtrFiles[tNr]^.EndOfFile := EOF( aPtrFiles[tNr]^.TxtFile );
            end;
{$ENDIF}
            if IsLess( tNr, nr ) then
              nr := tNr;
          end;  { if Length( aPtrFiles[tNr]^.Line ) > 0 }
        end;  { if tNr <> nr }
      end;  { for tNr := 1 to tMaxNr loop }

      if Length( aPtrFiles[nr]^.Line ) > 0 then
      begin
{$IFDEF NoDupes}
        if (CompUCStr( aPtrFiles[nr]^.Line, Line0 ) <> 0) then
        begin
{$ENDIF}
          writeln( OutputFile, aPtrFiles[nr]^.Line );
          if (IOResult <> 0) then
          begin
            writeln( 'Error writing ', DestFile );
            halt( 1 );
          end;
          inc( count );
          if (count mod divisor) = 0 then write( #13,'Merging ', count:7 );
{$IFDEF ReleaseTimeSlice}
          if (count mod 10000) = 0 then
            asm                { release time slice }
              mov   AX,$1680
              int   $2F
            end;
{$ENDIF}
{$IFDEF NoDupes}
        end;
{$ENDIF}
        StrCopy( aPtrFiles[nr]^.Line, Line0 );       { last written line }
        aPtrFiles[nr]^.Line := '';
      end;

      while (not aPtrFiles[nr]^.EndOfFile and not aPtrFiles[nr]^.Error)
      and (
{$IFDEF NoDupes}
      (CompUCStr( aPtrFiles[nr]^.Line, Line0 ) = 0) or
{$ENDIF}
      (Length( aPtrFiles[nr]^.Line ) = 0)) do
      begin
        ReadLn( aPtrFiles[nr]^.TxtFile, aPtrFiles[nr]^.Line );
        aPtrFiles[nr]^.Error := (IOResult <> 0);
        aPtrFiles[nr]^.EndOfFile := EOF( aPtrFiles[nr]^.TxtFile );
      end;

      if Length( aPtrFiles[nr]^.Line ) = 0 then
      begin
        tNr := 1;        { the first non-empty line }
        while Length( aPtrFiles[tNr]^.Line ) = 0 do inc( tNr );
        if (tNr <= tMaxNr) then nr := tNr;
      end;

      Ready := True;
      tNr := 1;
      while (tNr <= tMaxNr) and Ready do         { check for more lines }
      begin
        if (Length( aPtrFiles[tNr]^.Line ) > 0) then Ready := False;
        inc( tNr );
      end;
    end;  { while not Ready }
    Close( OutputFile );
    Writeln( #13,'Merged ', count:7, ' lines' );
  end;  { if CreateTextFile }

  for tNr := 1 to tMaxNr do
  begin
    Close( aPtrFiles[tNr]^.TxtFile );      { close and delete all temp files }
    Erase( aPtrFiles[tNr]^.TxtFile );
  end;
  Release( MarkPtr );
end  { MergeSort };


{$F+}
procedure OurExitProc;
begin
  ExitProc := OldExitProc;

  { Restore Old File Handle Table }
  MemW[PrefixSeg:$32] := OldSize;
  MemL[PrefixSeg:$34] := OldFHT;

  SetCursorOn;
end;
{$F-}


begin
  {set up our exit handler}

  OldExitProc := ExitProc;
  ExitProc := @OurExitProc;

  if ParamCount > 1 then           { parameters: inputfile(s) outputfile }
  begin
    SetCursorOff;
    TotalIn   := 0;
    TotalSort := 0;
    Line0 := '';
    UniekeEntry( TempDir );
    if not Exists then
    begin
      MkDir( TempDir );
      if (IOResult=0) then
      begin
        HeapError := @HeapFunc;
        DestFile := ParamStr( ParamCount );
        TempNr := 0;

        if fExist( DestFile ) then
        begin                              { if outputfile already exist }
          inc( TempNr );
          Byte2zStr( TempNr, 3, Temp );
          TempFile := TempDir + '\' + Temp;   { move it to the temp directory }
          if fRename( DestFile, TempFile ) then
            writeln( DestFile, ':', Temp, '  ' )
          else
            dec( TempNr );
        end;  { if fExist( DestFile ) }

        for ParamNr := 1 to (ParamCount-1) do         { all inputfile(s) }
        begin
          FMask := ParamStr( ParamNr );               { filemask         }
          FindFirst(FMask, FAttr, FR);
          while DosError = 0 do
          begin
            StrCopy( FR.Name, fName );
            Pad( fName, 12 );
            Process( FR.Name );
            FindNext( FR );
          end;
        end;  { all inputfile(s) }
        writeln( 'Total: input ', TotalIn, ', sorted ', TotalSort, ' lines   ' );

        { if one temp file rename it to destination, else merge sort }
        if TempNr = 1 then
        begin
          Byte2zStr( TempNr, 3, Temp );
          TempFile := TempDir + '\' + Temp;
          if not fRename( TempFile, DestFile ) then
            writeln( 'Could not rename ',TempFile,' to ',DestFile );
          {}
        end
        else
        begin
          MakeNewFHT;
          MergeSort;
        end;
        RmDir( TempDir );     { remove temporary directory }
      end   { if IOResult=0 }
      else
        writeln( 'Cannot create temporary directory!' );
      { }
    end;  { if not Exists TempDir }
  end   { if ParamCount > 1 }
  else
    WriteLn( 'Sort inputfile(s) outputfile ' );
  { }
end.